open Common

(* -------------------------------------------------------------------------- *)
(*  Lexical analysis                                                          *)
(* -------------------------------------------------------------------------- *)


let matches s = 
  let chars = explode s in 
    fun c -> mem c chars;;

let space = matches " \t\n";;
let punctuation = matches "()[]{},";;
let symbolic = matches "~`!@#$%^&*-+=|\\:;<>.?/";;
let numeric = matches "0123456789";;
let alphanumeric = matches
  "abcdefghijklmnopqrstuvwxyz_'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";;
let alpha = matches
  "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";;

let rec lexwhile prop inp =
  match inp with
    [] -> "",[]
  | c::cs ->
        if prop c then let tok,rest = lexwhile prop cs in c^tok,rest
        else "",inp;;

let rec lex inp =
  let _,inp1 = lexwhile space inp in
  match inp1 with
    [] -> []
  | c::cs -> let prop =
               if numeric(c) then numeric
               else if alphanumeric(c) then alphanumeric
               else if symbolic(c) then symbolic
               else if punctuation(c) then (fun c -> false)
               else failwith "Unknown character in input" in
             let toktl,rest = lexwhile prop cs in
             (c^toktl)::lex rest;;

(* -------------------------------------------------------------------------- *)
(*  Parsing                                                                   *)
(* -------------------------------------------------------------------------- *)

type token = string

type 'a parser = string list -> 'a * token list

exception Parse of string;;

let a tok inp = match inp with
  | h::t when h = tok -> h,t
  | _ -> raise (Parse "");;

let next l = match l with
  | (h::t) -> h,t
  | _ -> raise (Parse "next")

let papply f (ast,rest) = (f ast,rest);;

let nextin inp tok = inp <> [] & hd inp = tok;;

let rec ignore_upto tok inp = match inp with 
  | [] -> raise (Parse "")
  | h::t when h = tok -> inp
  | _::t -> ignore_upto tok t;;

let parse_bracketed subparser cbra inp =
  let ast,rest = subparser inp in
  if nextin rest cbra then ast,tl rest
  else failwith "Closing bracket expected";;

let rec parse_ginfix opsym opupdate sof subparser inp =
  let e1,inp1 = subparser inp in
  if inp1 <> [] & hd inp1 = opsym then
     parse_ginfix opsym opupdate (opupdate sof e1) subparser (tl inp1)
  else sof e1,inp1;;

let parse_left_infix opsym opcon =
  parse_ginfix opsym (fun f e1 e2 -> opcon(f e1,e2)) (fun x -> x);;

let parse_right_infix opsym opcon =
  parse_ginfix opsym (fun f e1 e2 -> f(opcon(e1,e2))) (fun x -> x);;

let parse_list opsym =
  parse_ginfix opsym (fun f e1 e2 -> (f e1)@[e2]) (fun x -> [x]);;

let make_parser pfn s =
  let expr,rest = pfn (lex(explode s)) in
  if rest = [] then expr else failwith "Unparsed input";;

let make_gen_parser lex pfn s =
  let expr,rest = pfn (lex(explode s)) in
  if rest = [] then expr else failwith "Unparsed input";;

let (||) parser1 parser2 input =
  try parser1 input
  with Parse _ -> parser2 input;;

let (++) parser1 parser2 input =
  let result1,rest1 = parser1 input in
  let result2,rest2 = parser2 rest1 in
    (result1,result2),rest2;;

let rec many prs input =
  try let result,next = prs input in
  let results,rest = many prs next in
    (result::results),rest
  with Parse _ -> [],input;;

let (>>) prs treatment input =
  let result,rest = prs input in
    treatment(result),rest;;

let fix err prs input =
  try prs input
  with Parse _ -> failwith (err ^ " expected");;

let rec listof prs sep err =
  prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);;

let nothing input = [],input;;

let elistof prs sep err =
  listof prs sep err || nothing;;

let rightbin prs sep cons err =
  listof prs sep err >> end_itlist cons;;

let leftbin prs sep cons err =
  listof prs sep err >> (end_itlist (c cons)) ** rev;;

let maybe prs input =
  try let x,rest = prs input in Some x,rest
  with Parse _ -> None,input;;

let some p =
  function
      [] -> raise (Parse "some")
    | (h::t) -> if p h then (h,t) else raise (Parse "some");;

let rec atleast n prs i =
  (if n <= 0 then many prs
   else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;;

(* -------------------------------------------------------------------------- *)
(*  Paring ops                                                                *)
(* -------------------------------------------------------------------------- *)

module Ops =
struct 
  let ( || ) = ( || )
  let ( ++ ) = ( ++ )
  let ( >> ) = ( >> )
end

(* -------------------------------------------------------------------------- *)
(*  Specific examples                                                         *)
(* -------------------------------------------------------------------------- *)

(* ---------------------------------  Ints  --------------------------------- *)

let parse_pos_int inp = match inp with 
  | (x::l) -> (try int_of_string x,l with Failure _ -> raise (Parse "int expected"))
  | _ -> raise (Parse "int expected");;

let parse_int = maybe (a "-") ++ parse_pos_int >> 
  (fun (x,y) -> match x with None -> y | Some "-" -> -y | _ -> raise (Parse ""));;

(* ---------------------------------  Ints  --------------------------------- *)

(* 
let parse_pos_num inp = match inp with 
  | (x::l) -> (try Num.num_of_string x,l with Failure _ -> raise (Parse "int expected"))
  | _ -> raise (Parse "int expected");;

let parse_num = maybe (a "-") ++ parse_pos_num >> 
  (fun (x,y) -> match x with None -> y | Some "-" -> Num.minus_num y | _ -> raise (Parse ""));;
*) 

(* --------------------------------  Floats  -------------------------------- *)

let rec lex_float inp =
  let _,inp1 = lexwhile space inp in
  match inp1 with
    [] -> []
  | c::cs -> let prop =
               if numeric(c) then numeric 
               else if alpha(c) then (fun c -> false)
               else if symbolic(c) then symbolic
               else if punctuation(c) then (fun c -> false)
               else failwith "Unknown character in input" in
             let toktl,rest = lexwhile prop cs in
             (c^toktl)::lex_float rest;;

let next inp = match inp with
  | h::t -> h,t
  | _ -> raise (Parse "");;

let parse_float = next ++ a "." ++ maybe next ++ maybe (a "E" ++ next) >> 
  (fun (((pre,_),post),exp) -> 
     let exp' = match exp with None -> "" | Some (_,n) -> "E" ^ n in
     let post' = match post with None -> "" | Some n -> n in
       float_of_string (pre ^ "." ^ post' ^ exp'));;

(* 

let float_of_string = float_of_string
#trace float_of_string

let toks = lex_float (explode "57983279.792478249E35392284")

parse_float (lex_float (explode "5.000"))
parse_float (lex_float (explode "57983279."))
parse_float (lex_float (explode "57983279.792478249E35"))
*) 

